perm filename QUEEN2.LSP[E82,JMC] blob
sn#679491 filedate 1982-09-26 generic text, type C, neo UTF8
COMMENT ā VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 queen2.lsp[e82,jmc] Backtrackers for n queens
C00011 00003 (defmacro increment (symbol) `(setq ,symbol (1+ ,symbol)))
C00028 00004 The simple n queens program
C00031 00005 subroutinized kill - from conversation with R. W. Floyd
C00050 ENDMK
Cā;
;;;queen2.lsp[e82,jmc] Backtrackers for n queens
;;; A general backtracking finder of all solutions of a problem.
;;; pos: A position in whatever notation chosen.
;;; sols: A list of solutions in a form found so far.
;;; (terp pos): the position pos is terminal, i.e. has not continuations.
;;; (winp pos): the position pos wins and should be added to list of
;;; solutions in a suitable form.
;;; (outform pos): the form in which pos is to be included in the
;;; list of solutions. Sometimes (outform pos) = pos.
;;; (moves pos): the list of updatable moves from pos.
;;; (update move pos): the position that results from making move in pos.
(defun solutions (pos sols)
(if (terp pos)
(if (winp pos) (cons (outform pos) sols) sols)
(do ((m (moves pos) (cdr m))
(s1 sols (solutions (update (car m) pos) s1)))
((null m) s1))))
;;; In general, the amount of information contained in a position
;;; will be large enough so that it is better to update and revert
;;; the data structures representing positions rather than save
;;; them on a stack. Moreover, the computations of terp, winp,
;;; and moves will not be independent, but will share computation.
;;; These fact suggest the "hidden board trick" whereby a board
;;; representation is updated and reverted as a side-effect of terp.
;;; In this case, at the outer level, the position can simply be
;;; represented by a list of the moves that led to it from the
;;; initial position.
;;; goes with complex nqueens
(defun update (move pos) (cons move pos))
;;; rectify and friends taken from McCarthy and Talcott
(defun rectify (p)
(prog (z q)
(setq q (commontail p p1))
l1 (if (equal q p1) (go l2))
(revert)
(go l1)
l2 (setq z (listsubt p p1))
l3 (if (null z) (return p))
(update (car z) pos)
(pop z)
(go l3)))
(defun commontail (u v) (reverse (commonhead (reverse u) (reverse v))))
(defun commonhead (u v) (if (or (null u) (null v) (not (equal (car u) (car v))))
nil
(cons (car u) (commonhead (cdr u) (cdr v)))))
(defun listsubt (u v) (listsubta u (- (length u) (length v)) nil))
(defun listsubta (u n z)
(if (zerop n)
z
(listsubta (cdr u) (1- n) (cons (car u) z))))
;;; Here is another version of rectify using do instead of the
;;; explicit loop. It doesn't seem more perspicuous to me.
(defun rectify (p)
(do ((z (listsubt p (do ((q (commontail p p1)))
((equal q p1) p1)
(revert))) (cdr z)))
((null z) p)
(update1 (car z) pos)))
(defun terp (pos)
(if (*catch 'noroom (let ((pp (rectify pos)))
(or (= nqueens n)
(do ((i 0 (1+ i))
(p t (and p (= (occfile i) n))))
((= i n) p)))))
(progn (setq ter-count (1+ ter-count)) t)
nil))
(defun winp (pos) (= nqueens n))
;;; (moves pos) is the list of available squares in the file or rank with fewest
;;; available squares.
(defun moves (pos)
(do ((i 0 (1+ i))
(mf 0 (if (< (occfile i) n) (max mf (occfile i)) mf))
(mr 0 (if (< (occrank i) n) (max mr (occrank i)) mr))
(bf 0 (if (and (< (occfile i) n) (< mf (occfile i))) i bf))
(br 0 (if (and (< (occrank i) n) (< mr (occrank i))) i br)))
((= i n) (if (< mf mr) (avails-in-rank br) (avails-in-file bf)))))
;;; (outform sol) gives the complete solution rather than just the
;;; moves up to the point where there is no further backtracking.
(defun outform (pos) solution)
;;; update1 calls (move sq), but we'll keep the communication with
;;; the tree search program here.
(defun update1 (sq pos)
(prog ( )
(push (do ((i 0 (1+ i))
(l nil (cons (cons
(occfile (- nm1 i))
(occrank (- nm1 i))) l)))
((= i n) l))
stack)
(push nqueens stack)
(setq solution (*catch 'lose (move sq)))
(push takeback stack)
(push sq p1)
(if (equal solution 'noroom) (*throw 'noroom t))
(return (cons sq pos))))
(defun revert ()
(prog ()
(do ((l (car stack) (cdr l)))
((null l))
(store (bd (rank (car l)) (file (car l))) 0))
(pop stack)
(setq nqueens (car stack))
(pop stack)
(do ((i 0 (1+ i))
(l (car stack) (cdr l)))
((= i n))
(store (occfile i) (caar l))
(store (occrank i) (cdar l))
)
(pop stack)
(pop p1)
(return p1)
))
;bfun
;(untrace)
;(trace kill rectify terp move update update1 moves winp revert occupy)
(init 6)
(solutions nil nil)
ter-count
delete1-count
;efun
;end
(defmacro increment (symbol) `(setq ,symbol (1+ ,symbol)))
(defun m (x y) (move (cons x y)))
(defun mb (x y) (prog () (move (cons x y)) (show)))
(defun delete1 (sq killflag)
(let* ((x (rank sq))
(y (file sq))
(or (1+ (occfile x)))
(of (1+ (occrank y))))
(prog ()
(if (not (zerop (bd x y))) (return nil))
(setq delete1-count (1+ delete1-count))
(store (bd x y) 1)
(push sq takeback)
(store (occfile x) or)
(store (occrank y) of)
(if (or (and (equal killflag 'both) (or (= n or) (= n of)))
(and (equal killflag 'rank) (= n or))
(and (equal killflag 'file) (= n of)))
(*throw 'lose 'noroom))
(if (= or nm1) (push x onefile))
(if (= or nm2) (push x twofile))
(if (= or nm3) (push x threefile))
(if (= of nm1) (push y onerank))
(if (= of nm2) (push y tworank))
(if (= of nm3) (push y threerank))
(return t)
)))
(defun occupy (sq)
(let ((x (rank sq)) (y (file sq)))
(delete1 sq nil)
(store (bd x y) 2)
(setq nqueens (1+ nqueens))
(do ((l1 (car (attack x y)) (cdr l1)))
((null l1)
)
(delete1 (car l1) 'rank))
(do ((l2 (cadr (attack x y)) (cdr l2)))
((null l2)
)
(delete1 (car l2) 'file))
(do ((l2 (caddr (attack x y)) (cdr l2)))
((null l2))
(delete1 (car l2) 'both))))
(DEFUN PRINTD (X) ((LAMBDA (U V) U) X (PRINT X)))
(defun move (sq)
(prog ()
(setq onefile nil)
(setq twofile nil)
(setq threefile nil)
(setq onerank nil)
(setq tworank nil)
(setq threerank nil)
(do ((i 0 (1+ i)))
((= i n))
(if (= (occfile i) nm1) (push i onefile))
(if (= (occfile i) nm2) (push i twofile))
(if (= (occfile i) nm3) (push i threefile))
(if (= (occrank i) nm1) (push i onerank))
(if (= (occrank i) nm2) (push i tworank))
(if (= (occrank i) nm3) (push i threerank)))
(setq takeback nil)
(occupy sq)
(kill)
(return (if (= nqueens n) (mksol) 'nonsolution))))
;;; Now look for other squares that can be deleted.
(defun kill ()
(prog (sq1 u)
loop (if (null onefile) (go l1)) ; Files with only one possible space
; can be occupied immediately.
(setq u (avails-in-file (car onefile)))
(if (not (null u)) (go l1a))
(pop onefile)
(go loop)
l1a (setq sq1 (car u))
(pop onefile)
(occupy sq1)
(go loop)
l1 (if (null onerank) (go l2)) ; ranks with only one possible space
(setq u (avails-in-rank (car onerank)))
(if (not (null u)) (go l1b))
(pop onerank)
(go l1)
l1b (setq sq1 (car u))
(pop onerank)
(occupy sq1)
(go loop)
l2
(if (null twofile) (go l3)) ; files with two spaces. Find and delete
; squares that attack both.
(if (= (occfile (car twofile)) nm2) (go l2a))
(pop twofile)
(go l2)
l2a (setq u (k2f (avails-in-file (car twofile))))
(pop twofile)
(if (purge u) (go loop))
l3 (if (null tworank) (go l4))
(if (= (occrank (car tworank)) nm2) (go l3a))
(pop tworank)
(go l3)
l3a (setq u (k2r (avails-in-rank (car tworank))))
(pop tworank)
(if (purge u) (go loop))
l4 (if (null threefile) (go l5))
(if (= (occfile (car threefile)) nm3) (go l4a))
(pop threefile)
(go l4)
l4a (setq u (k3f (avails-in-file (car threefile))))
(pop threefile)
(if (purge u) (go loop))
l5 (if (null threerank) (go l6))
(if (= (occrank (car threerank)) nm3) (go l5a))
(pop threerank)
(go l5)
l5a (setq u (k3r (avails-in-rank (car threerank))))
(pop threerank)
(if (purge u) (go loop))
l6
;(SHOW)
;(PF NQUEENS)
(return nqueens)
))
(defun mksol ()
(do ((i (1- n) (1- i))
(sol nil
(cons (do ((j 0 (1+ j))
(y 0 (if (= (bd i j) 2) j y)))
((= j n) y)) sol)))
((= i -1) sol)))
;;; (k3f u) is the list of squares that might kill a file with three
;;; unexcluded squares.
(defun k3f (u)
(let ((d (- (file (car u)) (file (cadr u)))))
(if (= (- (file (cadr u)) (file (caddr u))) d)
(list (mksq (+ (rank (car u)) d) (file (cadr u)))
(mksq (- (rank (car u)) d) (file (cadr u))))
nil)))
;;; (k3r u) is the list of squares that might kill a rank with three
;;; unexcluded squares.
(defun k3r (u)
(let ((d (- (rank (car u)) (rank (cadr u)))))
(if (= (- (rank (cadr u)) (rank (caddr u))) d)
(list (mksq (rank (cadr u)) (+ (file (car u)) d))
(mksq (rank (cadr u)) (- (file (car u)) d)))
nil)))
(defun k2f (u)
(let ((d (- (file (car u)) (file (cadr u)))))
(if
(evenp d)
(append
(let ((d1 (quotient d 2)))
(list (mksq (+ (rank (car u)) d1) (- (file (car u)) d1))
(mksq (- (rank (car u)) d1) (- (file (car u)) d1))))
(k2f1 u d))
(k2f1 u d)
)))
;;; k2f1 called by k2f gets the killing squares when there are two
;;; squares left in a file and difference is odd.
(defun k2f1 (u d) (list
(mksq (+ (rank (car u)) d) (file (car u)))
(mksq (- (rank (car u)) d) (file (car u)))
(mksq (+ (rank (cadr u)) d) (file (cadr u)))
(mksq (- (rank (cadr u)) d) (file (cadr u)))
))
(defun k2r (u)
(let ((d (- (rank (car u)) (rank (cadr u)))))
(if
(evenp d)
(append
(let ((d1 (quotient d 2)))
(list (mksq (- (rank (car u)) d1) (+ (file (car u)) d1))
(mksq (- (rank (car u)) d1) (- (file (car u)) d1))))
(k2r1 u d))
(k2r1 u d)
)))
;;; k2r1 called by k2r gets the killing squares when there are two
;;; squares left in a rank and difference is odd.
(defun k2r1 (u d) (list
(mksq (rank (car u)) (+ (file (car u)) d))
(mksq (rank (car u)) (- (file (car u)) d))
(mksq (rank (cadr u)) (+ (file (cadr u)) d))
(mksq (rank (cadr u)) (- (file (cadr u)) d))
))
;;; Removes a list of squares from board checking that they are on the board
;;; and are unoccupied.
;;; Returns t if it found any, otherwise nil.
(defun purge (l)
(do ((l1 l (cdr l1))
(p nil (or p (and (lessp -1 (rank (car l1)) n)
(lessp -1 (file (car l1)) n)
(delete1 (car l1) t)))))
((null l1) p)))
(defun show () (prog ()
(pf onefile)(pf twofile)(pf threefile)(pf onerank)(pf tworank)(pf threerank)
(occprint)
(terpri)
(do i n (1- i) (= i 0)
(do j 0 (1+ j) (= j n) (show1 (bd j (1- i))))
(terpri)
)
)
)
(defun show1 (k) (prog ()
(princ (if (lessp k 8) " " " "))
(prin1 k)))
(defmacro pf (f)
`(progn (terpri) (princ (quote ,f)) (princ " = ")
(princ (symeval (quote ,f)))
,f))
(defun init (n2) (prog ()
(setq p1 nil) ; the list of moves to the position
(setq ter-count 0)
(setq delete1-count 0)
(setq n n2)
(setq nqueens 0)
(setq sols nil)
(array bd fixnum n n)
(array attack t n n)
(fill-attack n2)
(array occfile fixnum n)
(array occrank fixnum n)
(setq stack nil)
(setq nm1 (1- n))
(setq nm2 (- n 2))
(setq nm3 (- n 3))
; (setq onefile nil)
; (setq twofile nil)
; (setq threefile nil)
; (setq onerank nil)
; (setq tworank nil)
; (setq threerank nil)
(setq takeback nil)
))
;;; (fill-attack n) : initializes the arrray (attack x y) of squares
;;; attacked from square (x.y).
(defun fill-attack (n)
(do ((x 0 (1+ x)))
((= x n))
(do ((y 0 (1+ y)))
((= y n))
(prog (l)
(setq l1 nil l2 nil l3 nil)
(do ((x1 0 (1+ x1)))
((= x1 n))
(if (not (= x1 x)) (push (cons x1 y) l1)))
(do ((y1 0 (1+ y1)))
((= y1 n))
(if (not (= y1 y)) (push (cons x y1) l2)))
(do ((d (max (- x) (- y)) (1+ d)))
((= d (min (- n x) (- n y))))
(if (not (zerop d)) (push (cons (+ x d) (+ y d)) l3)))
(do ((d (max (- x) (- y (1- n))) (1+ d)))
((= d (min (- n x) (1+ y))))
(if (not (zerop d)) (push (cons (+ x d) (- y d)) l3)))
(store (attack x y) (list l1 l2 l3))))))
(defun mksq (x y) (cons x y))
(defun rank (sq) (car sq))
(defun file (sq) (cdr sq))
;;; (avails-in-file x) : unattacked squares in file x.
(defun avails-in-file (x)
(do ((j 0 (1+ j))
(u nil (if (zerop (bd x j)) (cons (mksq x j) u) u)))
((= j n) u)))
;;; (avails-in-rank x) : unattacked squares in rank x.
(defun avails-in-rank (y)
(do ((i 0 (1+ i))
(u nil (if (zerop (bd i y)) (cons (mksq i y) u) u)))
((= i n) u)))
;;; (occfile x): the number of occupants of file x.
;;; (occrank y): the number of occupants of rank y.
;;; (attack x y): the squares attacked from square x, y - a constant array.
;;; takeback: a list of the squares occupied in present recursion
(defmacro restore (vals . vars)
`(mapc #'set ',vars ,vals))
; for debugging
(DEFUN OCCPRINT () (PROG ()
(terpri)
(do ((i 0 (1+ i))) ((= i n)) (princ (occfile i)))
(terpri)
(do ((i 0 (1+ i))) ((= i n)) (princ (occrank i)))
terpri
))
(defun consistent ()
(and
(setq test 'occfile-bd)
(do ((i 0 (1+ i))
(p t (and
p
(= (occfile i) (do ((j 0 (1+ j))
(s 0 (if (plusp (bd i j)) (1+ s) s)))
((= j n) s))))))
((= i n) p))
(setq test 'occrank-bd)
(do ((j 0 (1+ j))
(p t (and
p
(= (occrank j) (do ((i 0 (1+ i))
(s 0 (if (plusp (bd i j)) (1+ s) s)))
((= i n) s))))))
((= j n) p))
(setq test 'nqueens-bd)
(= nqueens (do ((i 0 (1+ i))
(s 0 (+ s (do ((j 0 (1+ j))
(s1 0 (if (= (bd i j) 2) (1+ s1) s1)))
((= j n) s1)))))
((= i n) s)))
(setq test 'number-queens-on-file)
(do ((i 0 (1+ i))
(p t (and p (< (do ((j 0 (1+ j))
(s 0 (if (= (bd i j) 2) (1+ s) s)))
((= j n) s)) 2))))
((= i n) p))
(setq test 'number-queens-on-rank)
(do ((j 0 (1+ j))
(p t (and p (< (do ((i 0 (1+ i))
(s 0 (if (= (bd i j) 2) (1+ s) s)))
((= i n) s)) 2))))
((= j n) p))
))
;bfun
;efun
;end
;;; The simple n queens program
;;; In the simple program for the n queens problem, a position is
;;; represented by a list of the column numbers of the squares
;;; in the rows so far occupied prefixed by the number of rows
;;; so far occupied. 8 queens is solved in 2'1''47''' and 6 queens
;;; in 6''12''' and 6"46 to get them without printing, so repeated
;;; trials would be needed if accuracy were wanted.
(defun solutions (pos sols)
(if (terp pos)
(if (winp pos) (cons (outform pos) sols) sols)
(do ((m (moves pos) (cdr m))
(s1 sols (solutions (update (car m) pos) s1)))
((null m) s1))))
(defun terp (pos) (> (car pos) n))
(defun winp (pos) t) ; the work is done by (moves pos).
(defun outform (pos) (cdr pos)) ; just get rid of the depth which will
; always be n.
(defun moves (pos)
(do ((l intn (cdr l))
(ms nil (if (ok (car l) (cdr pos))
(cons (car l) ms)
ms)))
((null l) ms)))
;;; this one goes with simple nqueens
(defun update (move pos) (cons (1+ (car pos)) (cons move (cdr pos))))
(defun queens (n)
(let ((intn (listint n)))
(solutions '(1) nil)))
(defun listint (n) (listint1 0 n))
(defun listint1 (k m) (if (= k m) nil (cons k (listint1 (1+ k) m))))
(defun ok (sq list) (ok1 sq list 1))
(defun ok1 (sq list n)
(or (null list)
(and (ok2 sq (car list)n)
(ok1 sq (cdr list) (1+ n)))))
(defun ok2 (sq sq1 delta) (not (or (= sq sq1)
(= sq (+ sq1 delta))
(= sq (- sq1 delta)) )))
(setq base (setq ibase 10.))
(queens 6)
SOLUTIONS
TERP
WINP
OUTFORM
MOVES
UPDATE
QUEENS
LISTINT
LISTINT1
OK
OK1
OK2
10.
;Loading LET 90
;Loading MLMAC 85
((4. 2. 0. 5. 3. 1.) (3. 0. 4. 1. 5. 2.) (2. 5. 1. 4. 0. 3.) (1. 3. 5.
0. 2. 4.))
;;; subroutinized kill - from conversation with R. W. Floyd
;;; purge uses the return from delete to say whether it purged anything.
(defun kill6 ()
(prog ()
l
(kill5)
l2
(if (null threerank) (return nil))
(if (= (occrank (car threerank)) nm3) (go l1))
(pop threerank)
(go l2)
l1
(setq u (k3r (avails-in rank (car threerank))))
(pop threerank)
(if (purge u) (go l) (return nil))
))
(defun kill6 (s) (kill62 (kill5 s)))
(defun kill62 (s) (if (null threerank)
s
(= (occrank (car threerank)) nm3)
(kill61 s)
(progn (pop threerank) (kill62 s))))
(defun kill61 (s) (prog (u)
(setq u (k3r (avails-in rank (car threerank))))
(pop threerank)
(if (purge u)
(kill6 s)
s)))
(defun kill6 () (progn (kill5) (kill62)))
(defun kill62 () (if (null threerank)
nil
(= (occrank (car threerank)) nm3)
(kill 61)
(progn (pop threerank) (kill62))))
(defun kill61 () (prog (u)
(setq u (k3r (avails-in-rank (car threerank))))
(pop threerank)
(and (purge u) (kill 6))))
;;; I just isn't clear hat all of this is an enormous improvement, but
there are certainly many more hooks for tracing.
If we were proving, it might be a pain to write the specifications
for all the little subroutines.
(defun solutions (pos sols)
(if (terp pos)
(if (winp pos) (cons (outform pos) sols) sols)
(do ((m (moves pos) (cdr m))
(s1 sols (solutions (update (car m) pos) s1)))
((null m) s1))))
; We need a new move generator, since the list of moves to be tried
can be cut off. No, it's not so bad. We can filter the moves by
running kill after each successive move square has been deleted,
but this is inefficient, so we'd better have a move generator after
all.
(defun solution (pos sols)
(if (terp pos)
(if (winp pos) (cons (outform pos) sols) sols)
(do ((m (moves pos) (cdr m))
(elim nil (cons (car m) elim)))
((dead m) s1))))
(defun dead (m) (or (null m)
(prog ()
(rectify pos)
(defun terp (pos)
(if (*catch 'noroom (let ((pp (rectify pos)))
(or (= nqueens n)
(do ((i 0 (1+ i))
(p t (and p (= (occfile i) n))))
((= i n) p)))))
(progn (setq ter-count (1+ ter-count)) t)
(prog () (setq takeback1 nil)
))